home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / forth / cforthu.arc / FORTH.C < prev    next >
C/C++ Source or Header  |  1985-07-11  |  14KB  |  536 lines

  1. /*
  2.  * forth.c
  3.  * 
  4.  * Portable FORTH interpreter in C
  5.  *
  6.  * Author: Allan Pratt, Indiana University (iuvax!apratt)
  7.  *         Spring, 1984
  8.  * References: 8080 and 6502 fig-FORTH source listings (not the greatest refs
  9.  *         in the world...)
  10.  *
  11.  * This program is intended to be compact, portable, and pretty complete.
  12.  * It is also intended to be in the public domain, and distribution should
  13.  * include this notice to that effect.
  14.  *
  15.  * This file contains the support code for all interpreter functions.
  16.  * the file prims.c contains code for the C-coded primitives, and the
  17.  * file forth.h connects the two with definitions.
  18.  *
  19.  * The program nf.c generates a new forth.core file from the dictionary
  20.  * forth.dict, using common.h to tie it together with this program.
  21.  */
  22.  
  23.  
  24. #include <stdio.h>
  25. #include <signal.h>
  26. #include <ctype.h>    /* only for isxdigit */
  27.  
  28. #include "common.h"
  29.  
  30. #include "forth.h"
  31.  
  32. #include "prims.h"    /* macro-defined primitives */
  33.  
  34. /* declare globals which are defined in forth.h */
  35.  
  36. unsigned short csp, rsp, ip, w;
  37. short *mem;
  38. int trace, tracedepth, debug, breakenable, breakpoint, qtermflag, forceip;
  39. int nobuf;
  40. FILE *blockfile;
  41. long bfilesize;
  42. char *bfilename;    /* block file name (change with -f ) */
  43. char *cfilename;    /* core file name  (change with -l ) */
  44. char *sfilename;    /* save file name  (change with -s ) */
  45.  
  46. /*
  47.              ----------------------------------------------------
  48.                                SYSTEM FUNCTIONS
  49.              ----------------------------------------------------
  50. */
  51.  
  52. errexit(s,p1,p2)        /* An error occurred -- clean up (?) and
  53.                    exit. */
  54. {
  55.     printf(s,p1,p2);
  56.     printf("ABORT FORTH!\nDumping to %s... ",DUMPFILE);
  57.     fflush(stdout);
  58.     memdump();
  59.     puts("done.");
  60.     exit(1);
  61. }
  62.  
  63. Callot (n)            /* allot n words in the dictionary */
  64. short n;
  65. {
  66.     unsigned newsize;
  67.  
  68.     mem[DP] += n;            /* move DP */
  69.     if (mem[DP] + GULPFRQ > mem[LIMIT]) {    /* need space */
  70.     newsize = mem[DP] + GULPSIZE;
  71.     if (newsize > MAXMEM && MAXMEM)
  72.         errexit("ATTEMPT TO GROW PAST MAXMEM (%d) WORDS\n",MAXMEM);
  73.  
  74.     mem = (short *)realloc((char *)mem, newsize*sizeof(*mem));
  75.     if (mem == NULL)
  76.         errexit("REALLOC FAILED\n");
  77.     mem[LIMIT] = newsize;
  78.     }
  79. }
  80.  
  81. push(v)            /* push value v to cstack */
  82. short v;
  83. {
  84.     if (csp <= TIB_END)
  85.     errexit("PUSH TO FULL CALC. STACK\n");
  86.     mem[--csp] = v;
  87. }
  88.  
  89. short pop()            /* pop a value from comp. stack, and return
  90.                    it as the value of the function */
  91. {
  92.     if (csp >= INITS0) {
  93.     puts("Empty Stack!");
  94.     return 0;
  95.     }
  96.     return (mem[csp++]);
  97. }
  98.  
  99. rpush(v)
  100. short v;
  101. {
  102.     if (rsp <= INITS0)
  103.     errexit("PUSH TO FULL RETURN STACK");
  104.     mem[--rsp] = v;
  105. }
  106.  
  107. short rpop()
  108. {
  109.     if (rsp >= INITR0)
  110.     errexit("POP FROM EMPTY RETURN STACK!");
  111.     return (mem[rsp++]);
  112. }
  113.  
  114. pkey()            /* (KEY) -- wait for a key & return it */
  115. {
  116.     int c;
  117.     if ((c = getchar()) == EOF) errexit("END-OF-FILE ENCOUNTERED");
  118.     return(c);
  119. }
  120.  
  121. pqterm()            /* (?TERMINAL): 
  122.                     return true if BREAK has been hit */
  123. {
  124.     if (qtermflag) {
  125.         push(TRUE);
  126.         qtermflag = FALSE;    /* this influences ^C handling */
  127.     }
  128.     else push(FALSE);
  129. }
  130.  
  131. pemit()                /* (EMIT): c --    emit a character */
  132. {
  133.     putchar(pop() & 0x7f);    /* stdout is unbuffered */
  134. }
  135.  
  136. next()            /* instruction processor: control goes here
  137.                    almost right away, and cycles through here
  138.                    until you leave. */
  139.  
  140. /* 
  141.  * This is the big kabloona. What it does is load the value at mem[ip]
  142.  * into w, increment ip, and invoke prim. number w. This implies that
  143.  * mem[ip] is the CFA of a word. What's in the CF of a word is the number
  144.  * of the primitive which should be executed. For a word written in FORTH,
  145.  * that primitive is "docol", which pushes ip to the return stack, then
  146.  * uses w+2 (the PFA of the word) as the new ip.  See "interp.doc" for
  147.  * more.
  148.  */
  149.  
  150. /*
  151.  * There is an incredible hack going on here: the SPECIAL CASE mentioned in
  152.  * the code is for the word EXECUTE, which must set W itself and jump INSIDE
  153.  * the "next" loop, by-passing the first instruction. This has been made a
  154.  * special case: if the primitive to execute is zero, the special case is
  155.  * invoked, and the code for EXECUTE is put right in the NEXT loop. For this
  156.  * reason, "EXECUTE" MUST BE THE FIRST WORD IN THE DICTIONARY.
  157.  */
  158. {
  159.     short p;
  160.     
  161.     while (1) {
  162.     if (forceip) {        /* force ip to this value -- used by sig_int */
  163.         ip = forceip;
  164.         forceip = FALSE;
  165.     }
  166. #ifdef TRACE
  167.     if (trace) dotrace();
  168. #endif TRACE
  169.  
  170. #ifdef BREAKPOINT
  171.     if (breakenable && ip == breakpoint) dobreak();
  172. #endif BREAKPOINT
  173.  
  174.     w = mem[ip];
  175.     ip++;
  176.                 /* w, mem, and ip are all global. W is now
  177.                    a POINTER TO the primitive number to 
  178.                    execute, and ip points to the NEXT thread to
  179.                    follow. */
  180.  
  181. next1:                /* This is for the SPECIAL CASE */
  182.     p = mem[w];        /* p is the actual number of the primitive */
  183.     if (p == 0) {        /* SPECIAL CASE FOR EXECUTE! */
  184.         w = pop();        /* see above for explanation */
  185.         goto next1;
  186.     }
  187.     /* else */
  188.     switch(p) {
  189.     case LIT    :  lit(); break;
  190.     case BRANCH    :  branch(); break;
  191.     case ZBRANCH    :  zbranch(); break;
  192.     case PLOOP    :  ploop(); break;
  193.     case PPLOOP    :  pploop(); break;
  194.     case PDO    :  pdo(); break;
  195.     case I        :  i(); break;
  196.     case R        :  r(); break;
  197.     case DIGIT    :  digit(); break;
  198.     case PFIND    :  pfind(); break;
  199.     case ENCLOSE    :  enclose(); break;
  200.     case KEY    :  key(); break;
  201.     case PEMIT    :  pemit(); break;
  202.     case QTERMINAL    :  qterminal(); break;
  203.     case CMOVE    :  cmove(); break;
  204.     case USTAR    :  ustar(); break;
  205.     case USLASH    :  uslash(); break;
  206.     case AND    :  and(); break;
  207.     case OR        :  or(); break;
  208.     case XOR    :  xor(); break;
  209.     case SPFETCH    :  spfetch(); break;
  210.     case SPSTORE    :  spstore(); break;
  211.     case RPFETCH    :  rpfetch(); break;
  212.     case RPSTORE    :  rpstore(); break;
  213.     case SEMIS    :  semis(); break;
  214.     case LEAVE    :  leave(); break;
  215.     case TOR    :  tor(); break;
  216.     case FROMR    :  fromr(); break;
  217.     case ZEQ    :  zeq(); break;
  218.     case ZLESS    :  zless(); break;
  219.     case PLUS    :  plus(); break;
  220.     case DPLUS    :  dplus(); break;
  221.     case MINUS    :  minus(); break;
  222.     case DMINUS    :  dminus(); break;
  223.     case OVER    :  over(); break;
  224.     case DROP    :  drop(); break;
  225.     case SWAP    :  swap(); break;
  226.     case DUP    :  dup(); break;
  227.     case TDUP    :  tdup(); break;
  228.     case PSTORE    :  pstore(); break;
  229.     case TOGGLE    :  toggle(); break;
  230.     case FETCH    :  fetch(); break;
  231.     case CFETCH    :  cfetch(); break;
  232.     case TFETCH    :  tfetch(); break;
  233.     case STORE    :  store(); break;
  234.     case CSTORE    :  cstore(); break;
  235.     case TSTORE    :  tstore(); break;
  236.     case DOCOL    :  docol(); break;
  237.     case DOCON    :  docon(); break;
  238.     case DOVAR    :  dovar(); break;
  239.     case DOUSE    :  douse(); break;
  240.     case SUBTRACT    :  subtract(); break;
  241.     case EQUAL    :  equal(); break;
  242.     case NOTEQ    :  noteq(); break;
  243.     case LESS    :  less(); break;
  244.     case ROT    :  rot(); break;
  245.     case DODOES    :  dodoes(); break;
  246.     case DOVOC    :  dovoc(); break;
  247.     case ALLOT    :  allot(); break;
  248.     case PBYE    :  pbye(); break;
  249.     case TRON    :  tron(); break;
  250.     case TROFF    :  troff(); break;
  251.     case DOTRACE    :  dotrace(); break;
  252.     case PRSLW    :  prslw(); break;
  253.     case PSAVE    :  psave(); break;
  254.     case PCOLD    :  pcold(); break;
  255.     default        :  errexit("Bad execute-code %d\n",p); break;
  256.     }
  257.     }
  258. }
  259.  
  260. dotrace()
  261. {
  262.     short worka, workb, workc;
  263.     putchar('\n');
  264.     if (tracedepth) {        /* show any stack? */
  265.         printf("sp: %04x (", csp);
  266.         worka = csp;
  267.         for (workb = tracedepth; workb; workb--)
  268.             printf("%04x ",(unsigned short) mem[worka++]);
  269.         putchar(')');
  270.     }
  271.     printf(" ip=%04x ",ip);
  272.  
  273.     if (mem[R0]-rsp < RS_SIZE && mem[R0] - rsp > 0) /* if legal rsp */
  274.         for (worka = mem[R0]-rsp; worka; worka--) { /* indent */
  275.         putchar('>');
  276.         putchar(' ');
  277.         }
  278.     worka = mem[ip] - 3;        /* this is second-to-last letter, or
  279.                        the count byte */
  280.     while (!(mem[worka] & 0x80)) worka--;    /* skip back to count byte */
  281.     workc = mem[worka] & 0x2f;        /* workc is count value */
  282.     worka++;
  283.     while (workc--) putchar(mem[worka++] & 0x7f);
  284.     fflush(stdout);
  285.     if (debug) {        /* wait for \n -- any other input will dump */
  286.         char buffer[10];
  287.         if (*gets(buffer) != '\0') {
  288.             printf("dumping core... ");
  289.             fflush(stdout);
  290.             memdump();
  291.             puts("done.");
  292.         }
  293.     }
  294. }
  295.  
  296. #ifdef BREAKPOINT
  297. dobreak()
  298. {
  299.     int temp;
  300.     puts("Breakpoint.");
  301.     printf("Stack pointer = %x:\n",csp);
  302.     for (temp = csp; temp < INITS0; temp++)
  303.         printf("\t%04x",mem[temp]);
  304.     putchar('\n');
  305. }
  306. #endif BREAKPOINT
  307.  
  308. main(argc,argv)
  309. int argc;
  310. char *argv[];
  311. {
  312.     FILE *fp;
  313.     unsigned short size;
  314.     int i = 1;
  315.  
  316.     cfilename = COREFILE;    /* "forth.core" */
  317.     bfilename = BLOCKFILE;    /* "forth.block" */
  318.     sfilename = SAVEFILE;    /* "forth.newcore" */
  319.     trace = debug = breakenable = nobuf = 0;
  320.  
  321.     while (i < argc) {
  322.         if (*argv[i] == '-') {
  323.             switch (*(argv[i]+1)) {
  324. #ifdef TRACE
  325.             case 'd':            /* -d[n] */
  326.                 debug = 1;    /* ...and fall through */
  327.             case 't':            /* -t[n] */
  328.                 trace = TRUE;
  329.                 if (argv[i][2])
  330.                     tracedepth = (argv[i][2] - '0');
  331.                 else tracedepth = 0;
  332.                 break;
  333. #else !TRACE
  334.             case 'd':
  335.             case 't':
  336.                 fprintf(stderr,
  337.         "Must compile with TRACE defined for -t or -d\n");
  338.                 break;
  339. #endif TRACE
  340.             case 'c': if (++i == argc) usage(argv[0]);
  341.                   cfilename = argv[i];        /* -c file */
  342.                   break;
  343.             case 's': if (++i == argc) usage(argv[0]);
  344.                   sfilename = argv[i];        /* -s file */
  345.                   break;
  346. #ifdef BREAKPOINT
  347.             case 'p': if (++i == argc) usage(argv[0]);
  348.                   breakenable = TRUE;    /* -p xxxx */
  349.                   breakpoint = xtoi(argv[i]);
  350.                   break;
  351. #else !BREAKPOINT
  352.             case 'p': fprintf(stderr,
  353.         "Must compile with BREAKPOINT defined for -p");
  354.                   break;
  355. #endif BREAKPOINT
  356.             case 'b': if (++i == argc) usage();
  357.                   bfilename = argv[i]; /* -b blockfile */
  358.                   break;
  359.             case 'n': nobuf = TRUE;
  360.                   break;
  361.             default: usage(argv[0]);
  362.                  exit(1);
  363.             }
  364.         }
  365.         else usage(argv[0]);        /* not a dash */
  366.         i++;
  367.     }
  368.  
  369.     if ((fp = fopen(cfilename,"r")) == NULL) {
  370.         fprintf(stderr,"Forth: Could not open %s\n", cfilename);
  371.         exit(1);
  372.     }
  373.     if (fread(&size, sizeof(size), 1, fp) != 1) {
  374.         fprintf(stderr,"Forth: %s is empty.\n",cfilename);
  375.         exit(1) ;
  376.     }
  377.  
  378.     if ((mem = (short *)calloc(size, sizeof(*mem))) == NULL) {
  379.         fprintf(stderr, "Forth: unable to malloc(%d,%d)\n",
  380.             size, sizeof(*mem));
  381.         exit(1);
  382.     }
  383.  
  384.     mem[LIMIT] = size;
  385.  
  386.     if (fread(mem+1, sizeof(*mem), size-1, fp) != size-1) {
  387.         fprintf(stderr, "Forth: not %d bytes on %s.\n",
  388.             size, cfilename);
  389.         exit(1);
  390.     }
  391.  
  392.     fclose(fp);
  393.  
  394.     initsignals();
  395.  
  396.     getblockfile();
  397.  
  398.     if (!nobuf) setbuf(stdout,NULL);
  399.  
  400.     if (ip = mem[SAVEDIP]) {    /* if savedip != 0, that is */
  401.         csp = mem[SAVEDSP];
  402.         rsp = mem[SAVEDRP];
  403.         puts("restarting a saved FORTH image");
  404.     }
  405.     else {
  406.         ip = mem[COLDIP];    /* this is the ip passed from nf.c */
  407.             /* ip now points to a word holding the CFA of COLD */
  408.         rsp = INITR0;        /* initialize return stack */
  409.         csp = INITS0;
  410.     }
  411.     next();
  412.     /* never returns */
  413. }
  414.  
  415. usage(s)
  416. char *s;
  417. {
  418.     fprintf(stderr, "usage:\n");
  419.     fprintf(stderr, "%s [-t[n]] [-d[n]] [-p xxxx] [-n]\n",s);
  420.     fputs(stderr, "\t[-c corename] [-b blockname] [-s savename]\n");
  421.     fputs(stderr, "Where:\n");
  422.     fputs(stderr,
  423. "-t[n]\t\tsets trace mode\n");
  424.     fputs(stderr,
  425. "-d[n]\t\tsets trace mode and debug mode (waits for newline)");
  426.     fputs(stderr,
  427. "\t\t[n] above sets stack depth to display. Single digit, 0-9. Default 0.\n");
  428.     fputs(stderr,
  429. "-p xxxx\t\tsets a breakpoint at xxxx (in hex), shows stack when reached\n");
  430.     fputs(stderr,
  431. "-n\t\tleaves stdout line-buffered\n");
  432.     fprintf(stderr,
  433. "-c corename\tuses corename as the core image (default %s without -c)\n",
  434.         COREFILE);
  435.     fprintf(stderr,
  436. "-b blockname\tuses blockname as the blockfile (default %s without -b)\n",
  437.         BLOCKFILE);
  438.     fprintf(stderr,
  439. "-s savename\tuses savename as the save-image file (default %s without -s)\n",
  440.         SAVEFILE);
  441. }
  442.  
  443. memdump()        /* dump core. */
  444. {
  445.     int i;    /* top of RAM */
  446.     int temp, tempb, firstzero, nonzero;
  447.     char chars[9], outline[80], tstr[6];
  448.     FILE *dumpfile;
  449.  
  450.     dumpfile = fopen(DUMPFILE,"w");
  451.  
  452.     fprintf(dumpfile,
  453.         "CSP = 0x%x  RSP = 0x%x  IP = 0x%x  W = 0x%x  DP = 0x%x\n",
  454.         csp, rsp, ip, w, mem[DP]);
  455.  
  456.     for (temp = 0; temp < mem[LIMIT]; temp += 8) {
  457.         nonzero = FALSE;
  458.         sprintf(outline, "%04x:", temp);
  459.         for (i=temp; i<temp+8; i++) {
  460.             sprintf(tstr," %04x", (unsigned short)mem[i]);
  461.             strcat(outline, tstr);
  462.             tempb = mem[i] & 0x7f;
  463.             if (tempb < 0x7f && tempb >= ' ')
  464.                 chars[i%8] = tempb;
  465.             else
  466.                 chars[i%8] = '.';
  467.             nonzero |= mem[i];
  468.         }
  469.         if (nonzero) {
  470.             fprintf(dumpfile,"%s %s\n",outline,chars);
  471.             firstzero = TRUE;
  472.         }
  473.         else if (firstzero) {
  474.             fprintf(dumpfile, "----- ZERO ----\n");
  475.             firstzero = FALSE;
  476.         }
  477.     }
  478.     fclose(dumpfile);
  479. }
  480.  
  481. /* here is where ctype.h is used */
  482.  
  483. xtoi(s)
  484. char *s;
  485. {                /*  convert hex ascii to integer */
  486.     int temp = 0;
  487.  
  488.     while (isxdigit (*s)) {    /* first non-hex char ends */
  489.     temp <<= 4;        /* mul by 16 */
  490.     if (isupper (*s))
  491.         temp += (*s - 'A') + 10;
  492.     else
  493.         if (islower (*s))
  494.         temp += (*s - 'a') + 10;
  495.         else
  496.         temp += (*s - '0');
  497.     s++;
  498.     }
  499.     return temp;
  500. }
  501.  
  502. /*
  503.  * Interrupt (^C) handling: If the user hits ^C once, the next pqterm call
  504.  * will return TRUE. If he hits ^C again before pqterm is called, there will
  505.  * be a forced jump to ABORT next time we hit next(). If it is a primitive
  506.  * that is caught in an infinite loop, this won't help any.
  507.  */
  508.  
  509. sig_int()
  510. {
  511.     if (qtermflag) {        /* second time? */
  512.         forceip = mem[ABORTIP];    /* checked each time through next */
  513.         qtermflag = FALSE;
  514.         trace = FALSE;        /* stop tracing; reset */
  515.     }
  516.     else qtermflag = TRUE;
  517. }
  518.  
  519. initsignals()
  520. {
  521.     signal(SIGINT,sig_int);
  522. }
  523.  
  524. getblockfile()
  525. {
  526.     /* recall that opening with mode "a+" opens for reading and writing */
  527.     /* with the pointer positioned at the end; this is so ftell returns */
  528.     /* the size of the file.                        */
  529.  
  530.     if ((blockfile = fopen(bfilename, "a+")) == NULL)
  531.         errexit("Can't open blockfile \"%s\"\n", bfilename);
  532.     bfilesize = ftell(blockfile);
  533.  
  534.     printf("Block file has %d blocks.\n",(int) (bfilesize/1024) - 1);
  535. }
  536.